# speaker informativity
# ---------------------
speaker.inf = function(d, alpha, cost = 0) {
exp(alpha*(log(d) - cost))
}
# speaker likelihood
# ------------------
speaker.lhd = function(rating, degree, m, alpha) {
numerator = speaker.inf(m[rating, degree], alpha)
normalize = sum(sapply(m[rating, ], function(i) {speaker.inf(i, alpha)}))
return(numerator / normalize)
}
# non-normalized posterior
# -----------------------
nn.post = function(rating, degree, m, alpha, useprior) {
prior = priors[rating, "prior.p"]
return(speaker.lhd(rating, degree, m, alpha) * prior)
}
# normalized posterior
# --------------------
norm.post = function(rating, degree, m, alpha, useprior) {
nn = nn.post(rating, degree, m, alpha, useprior)
normalize = sum(unlist(sapply(seq(1, 5), function(i){nn.post(i, degree, m, alpha, useprior)})))
return(nn / normalize)
}
# run.partial()
# ------------
# Run RSA with model1 (entailment) and model2 (entailment + generic)
run.partial = function(d, alpha=1, useprior=F, usenone=F, normalize=F) {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi = hi / sum(hi),
low = low / sum(low)) %>%
select(hi, low)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi, low)
}
if (usenone) {
mat$none = c(1, 0, 0, 0, 0)
}
d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree,
MoreArgs = list(m = mat,
alpha = alpha,
useprior = useprior))),
digits=4)
return(d)
}
# run.full()
# ------------
# Run RSA with model3 (full) with alternatives
run.full = function(d, alpha=1, useprior=F, usenone=F, addMid=F, normalize=F) {
# alpha = scales.entropy[scales.entropy$scale==d$scale[1], ]$Entropy
if (addMid) {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi1 = hi1 / sum(hi1),
hi2 = hi2 / sum(hi2),
mid = mid / sum(mid),
low1 = low1 / sum(low1),
low2 = low2 / sum(low2)) %>%
select(hi1, hi2, mid, low1, low2)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi1, hi2, mid, low1, low2)
}
} else {
if (normalize) {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
mutate(hi1 = hi1 / sum(hi1),
hi2 = hi2 / sum(hi2),
low1 = low1 / sum(low1),
low2 = low2 / sum(low2)) %>%
select(hi1, hi2, low1, low2)
} else {
mat = d %>%
select(stars, degree, speaker.p) %>%
spread(degree, speaker.p) %>%
select(hi1, hi2, low1, low2)
}
}
if (usenone) {
mat$none = c(1, 0, 0, 0, 0)
}
d$pred = round(as.numeric(mapply(norm.post, d$stars, d$degree,
MoreArgs = list(m = mat,
alpha = alpha,
useprior = useprior))),
digits=4)
return(d)
}
# tune.alhpa()
# ------------
# d --> data
# alphas --> range of alphas to test
# type --> full or partial model
# useprior --> use uniform prior
# usenone --> use gener None
tune.alpha = function(d, alphas = seq(from=1, to=10),
type="partial", useprior = T,
usenone=F, compare.data=NULL, addMid = F, normalize=F) {
# Tune best alphas
fit = sapply(alphas, FUN=function(n) {
if (type == "partial") {
md = d %>%
do(run.partial(., alpha=n, useprior=useprior, usenone=usenone, normalize=normalize))
} else {
md = d %>%
do(run.full(., alpha=n, useprior=useprior, usenone=usenone, addMid=addMid, normalize=normalize))
}
# Toggle fit to e6 data
if (!is.null(compare.data)) {
# If we're using e11 data with multiple scalars
if ("hi1" %in% md$degree) {
matched.items = which((md[, "scale"] != "some_all" &
(md[, "degree"] == "hi2" | md[, "degree"] == "hi1")) |
(md[, "scale"] == "some_all" &
(md[, "degree"] == "hi1" | md[, "degree"] == "low1")))
md = md[matched.items, ]
md$degree = ifelse(md$degree == "hi1", "hi", "low")
stopifnot("listener.p" %in% colnames(compare.data))
}
md$listener.p = compare.data$listener.p
}
# MSE
return(mean((md$pred - md$listener.p)^2))
})
# get lowest MSE
best.alpha = which(fit == min(fit))
return(best.alpha)
}
# Uniform priors
unif.priors = data.frame(stars = seq(1, 5), prior.p = rep(0.2, 5))
emp.priors = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/emp_priors.csv")
priors = unif.priors
scales.entropy = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/scales_entropy.csv")
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e8.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e6.csv")
# Combine speaker / listener
data.partial = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10.csv")
listener = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L1_e11.csv")
data.full = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
speaker = read.csv("~/Desktop/Projects/scalar_implicature/models/model_data/L0_e10a.csv")
data.full.extras = left_join(speaker, listener) %>%
left_join(priors) %>%
rowwise %>%
select(scale, degree, stars, speaker.p, listener.p, prior.p) %>%
mutate(listener.p = ifelse(is.na(listener.p), 0, listener.p)) %>%
group_by(scale)
## Joining by: c("scale", "degree", "stars")
## Warning in left_join_impl(x, y, by$x, by$y): joining factors with different
## levels, coercing to character vector
## Joining by: "stars"
## Warning: Grouping rowwise data frame strips rowwise nature
matched.items = which((data.full[, "scale"] != "some_all" &
(data.full[, "degree"] == "hi2" | data.full[, "degree"] == "hi1")) |
(data.full[, "scale"] == "some_all" &
(data.full[, "degree"] == "hi1" | data.full[, "degree"] == "low1")))
matched.items.extras = which((data.full.extras[, "scale"] != "some_all" &
(data.full.extras[, "degree"] == "hi2" | data.full.extras[, "degree"] == "hi1")) |
(data.full.extras[, "scale"] == "some_all" &
(data.full.extras[, "degree"] == "hi1" | data.full.extras[, "degree"] == "low1")))
# Save performance output
performance.output = data.frame(model=rep(NA, 16),
cor.e6=rep(NA, 16),
cor.e11=rep(NA, 16),
normalized=rep(NA, 16))
alphas = rep(NA, 16)
data.full.transfer = data.full[matched.items, ]
data.full.transfer$degree =
ifelse(data.full.transfer$degree == "hi1", "hi", "low")
# Model 1 - Entailment only models
# --------------------------------
# 1.a)
# Entailment only
# Normalized = T
# alpha tuning = F
alphas[1] = 1
m1.a = data.partial %>%
do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=T))
# Store output and add e11
m1.a = cbind(m1.a, data.full.transfer$listener.p)
colnames(m1.a)[8] = "e11.listener.p"
performance.output[1, ] = c("m1.a", round(cor(m1.a$listener.p, m1.a$pred), 5),
round(cor(m1.a$e11.listener.p, m1.a$pred), 5), T)
# Store plot
m1.a.plot = qplot(stars, listener.p, col=degree,
data=m1.a,
main=paste("m1.a\nalpha: ", alphas[1],
"\nNormalized = ", T,
"\nCorr = ", performance.output[1, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.b)
# Entailment only
# Normalized = F
# alpha tune = F
alphas[2] = 1
m1.b = data.partial %>%
do(run.partial(., alpha = alphas[1], useprior=T, usenone=F, normalize=F))
# Store output
m1.b = cbind(m1.b, data.full.transfer$listener.p)
colnames(m1.b)[8] = "e11.listener.p"
performance.output[2, ] = c("m1.b", round(cor(m1.b$listener.p, m1.b$pred), 5),
round(cor(m1.b$e11.listener.p, m1.b$pred), 5), F)
# Store plot
m1.b.plot = qplot(stars, listener.p, col=degree,
data=m1.b,
main=paste("m1.b\nalpha: ", alphas[2],
"\nNormalized = ", F,
"\nCorr = ", performance.output[2, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.c)
# Entailment only
# Normalized = T
# alpha tune = T
alphas[3] = tune.alpha(data.partial, normalize=T, compare.data=data.full.transfer)
m1.c = data.partial %>%
do(run.partial(., alpha = alphas[3], useprior=T, usenone=F, normalize=T))
# Store output
m1.c = cbind(m1.c, data.full.transfer$listener.p)
colnames(m1.c)[8] = "e11.listener.p"
performance.output[3, ] = c("m1.c", round(cor(m1.c$listener.p, m1.c$pred), 5),
round(cor(m1.c$e11.listener.p, m1.c$pred), 5), T)
# Store plot
m1.c.plot = qplot(stars, listener.p, col=degree,
data=m1.c,
main=paste("m1.c\nalpha: ", alphas[3],
"\nNormalized = ", T,
"\nCorr = ", performance.output[3, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 1.d)
# Entailment only
# Normalized = F
# alpha tune = T
alphas[4] = tune.alpha(data.partial, normalize=F)
m1.d = data.partial %>%
do(run.partial(., alpha = alphas[4], useprior=T, usenone=F, normalize=F))
# Store output
m1.d = cbind(m1.d, data.full.transfer$listener.p)
colnames(m1.d)[8] = "e11.listener.p"
performance.output[4, ] = c("m1.d", round(cor(m1.d$listener.p, m1.d$pred), 5),
round(cor(m1.d$e11.listener.p, m1.d$pred), 5), normalized=F)
# Store plot
m1.d.plot = qplot(stars, listener.p, col=degree,
data=m1.d,
main=paste("m1.d\nalpha: ", alphas[4],
"\nNormalized = ", F,
"\nCorr = ", performance.output[4, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 2 - Entailment + generic none
# --------------------------------
# 2.a)
# Entailment + generic None
# Normalized = T
# alpha tuning = F
alphas[5] = 1
m2.a = data.partial %>%
do(run.partial(., alpha = alphas[5], useprior=T, usenone=T, normalize=T))
# Store output
m2.a = cbind(m2.a, data.full.transfer$listener.p)
colnames(m2.a)[8] = "e11.listener.p"
performance.output[5, ] = c("m2.a", round(cor(m2.a$listener.p, m2.a$pred), 5),
round(cor(m2.a$e11.listener.p, m2.a$pred), 5), T)
# Store plot
m2.a.plot = qplot(stars, listener.p, col=degree,
data=m2.a,
main=paste("m2.a\nalpha: ", alphas[5],
"\nNormalized = ", T,
"\nCorr = ", performance.output[5, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.b)
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[6] = 1
m2.b = data.partial %>%
do(run.partial(., alpha = alphas[6], useprior=T, usenone=T, normalize=F))
# Store output
m2.b = cbind(m2.b, data.full.transfer$listener.p)
colnames(m2.b)[8] = "e11.listener.p"
performance.output[6, ] = c("m2.b", round(cor(m2.b$listener.p, m2.b$pred), 5),
round(cor(m2.b$e11.listener.p, m2.b$pred), 5), F)
# Store plot
m2.b.plot = qplot(stars, listener.p, col=degree,
data=m2.b,
main=paste("m2.b\nalpha: ", alphas[6],
"\nNormalized = ", F,
"\nCorr = ", performance.output[6, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.c)
# Entailment + generic None
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[7] = tune.alpha(data.partial, normalize=T, compare.data=NULL)
m2.c = data.partial %>%
do(run.partial(., alpha = alphas[7], useprior=T, usenone=T, normalize=T))
# Store output
m2.c = cbind(m2.c, data.full.transfer$listener.p)
colnames(m2.c)[8] = "e11.listener.p"
performance.output[7, ] = c("m2.c", round(cor(m2.c$listener.p, m2.c$pred), 5),
round(cor(m2.c$e11.listener.p, m2.c$pred), 5), T)
# Store plot
m2.c.plot = qplot(stars, listener.p, col=degree,
data=m2.c,
main=paste("m2.c\nalpha: ", alphas[7],
"\nNormalized = ", T,
"\nCorr = ", performance.output[7, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 2.d)
# Entailment + generic None
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.full.transfer for e11 or NULL for e6
alphas[8] = tune.alpha(data.partial, normalize=F)
m2.d = data.partial %>%
do(run.partial(., alpha = alphas[8], useprior=T, usenone=T, normalize=F))
# Store output
m2.d = cbind(m2.d, data.full.transfer$listener.p)
colnames(m2.d)[8] = "e11.listener.p"
performance.output[8, ] = c("m2.d", round(cor(m2.d$listener.p, m2.d$pred), 5),
round(cor(m2.d$e11.listener.p, m2.d$pred), 5), F)
# Store plot
m2.d.plot = qplot(stars, listener.p, col=degree,
data=m2.d,
main=paste("m2.d\nalpha: ", alphas[8],
"\nNormalized = ", F,
"\nCorr = ", performance.output[8, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 3 - Empirical alternatives
# --------------------------------
# 3.a)
# Emp alts
# Normalized = T
# alpha tuning = F
alphas[9] = 1
m3.a = data.full %>%
do(run.full(., alpha = alphas[9], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.a.matched = m3.a[matched.items, ]
m3.a.matched$degree = ifelse(m3.a.matched$degree == "hi1", "hi", "low")
m3.a.matched = cbind(m3.a.matched, data.partial$listener.p)
all(m3.a.matched$scale == data.partial$scale & m3.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.a.matched)[length(colnames(m3.a.matched))] = "e6.listener.p"
# Store output
performance.output[9, ] = c("m3.a", round(cor(m3.a.matched$e6.listener.p, m3.a.matched$pred), 5),
round(cor(m3.a.matched$listener.p, m3.a.matched$pred), 5), T)
# Store plot
m3.a.plot = qplot(stars, e6.listener.p, col=degree,
data=m3.a.matched,
main=paste("m3.a\nalpha: ", alphas[9],
"\nNormalized = ", T,
"\nCorr = ", performance.output[9, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.b)
# Emp alts
# Entailment + generic None
# Normalized = F
# alpha tune = F
alphas[10] = 1
m3.b = data.full %>%
do(run.full(., alpha = alphas[10], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.b.matched = m3.b[matched.items, ]
m3.b.matched$degree = ifelse(m3.b.matched$degree == "hi1", "hi", "low")
m3.b.matched = cbind(m3.b.matched, data.partial$listener.p)
all(m3.b.matched$scale == data.partial$scale & m3.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.b.matched)[length(colnames(m3.b.matched))] = "e6.listener.p"
# Store output
performance.output[10, ] = c("m3.b", round(cor(m3.b.matched$e6.listener.p, m3.b.matched$pred), 5),
round(cor(m3.b.matched$listener.p, m3.b.matched$pred), 5), F)
# Store plot
m3.b.plot = qplot(stars, e6.listener.p, col=degree,
data=m3.b.matched,
main=paste("m3.b\nalpha: ", alphas[10],
"\nNormalized = ", F,
"\nCorr = ", performance.output[10, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.c)
# Emp alts
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial for e6 or NULL for e11
alphas[11] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=T)
m3.c = data.full %>%
do(run.full(., alpha = alphas[11], addMid=F, normalize=T))
# Match with e6 w/ checks
m3.c.matched = m3.c[matched.items, ]
m3.c.matched$degree = ifelse(m3.c.matched$degree == "hi1", "hi", "low")
m3.c.matched = cbind(m3.c.matched, data.partial$listener.p)
all(m3.c.matched$scale == data.partial$scale & m3.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.c.matched)[length(colnames(m3.c.matched))] = "e6.listener.p"
# Store output
performance.output[11, ] = c("m3.c", round(cor(m3.c.matched$e6.listener.p, m3.c.matched$pred), 5),
round(cor(m3.c.matched$listener.p, m3.c.matched$pred), 5), T)
# Store plot 2 - both e6 and e11 data
m3.c.jointD = m3.c.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m3.c.jointD$study = ifelse(m3.c.jointD$study == "e6.listener.p", "e6", "e11")
m3.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m3.c.jointD,
main=paste("m3.c\nalpha: ", alphas[11],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 3.d)
# Emp alts
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[12] = tune.alpha(data.full, type = "full", compare.data=data.partial, addMid=F, normalize=F)
m3.d = data.full %>%
do(run.full(., alpha = alphas[12], addMid=F, normalize=F))
# Match with e6 w/ checks
m3.d.matched = m3.d[matched.items, ]
m3.d.matched$degree = ifelse(m3.d.matched$degree == "hi1", "hi", "low")
m3.d.matched = cbind(m3.d.matched, data.partial$listener.p)
all(m3.d.matched$scale == data.partial$scale & m3.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m3.d.matched)[length(colnames(m3.d.matched))] = "e6.listener.p"
# Store output
performance.output[12, ] = c("m3.d", round(cor(m3.d.matched$e6.listener.p, m3.d.matched$pred), 5),
round(cor(m3.d.matched$listener.p, m3.d.matched$pred), 5), F)
# Store plot 2 - both e6 and e11 data
m3.d.jointD = m3.d.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m3.d.jointD$study = ifelse(m3.d.jointD$study == "e6.listener.p", "e6", "e11")
m3.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m3.d.jointD,
main=paste("m3.d\nalpha: ", alphas[12],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# Model 4 - Empirical alternatives + extras
# -----------------------------------------
# 4.a)
# Emp alts + extras
# Normalized = T
# alpha tuning = F
alphas[13] = 1
m4.a = data.full.extras %>%
do(run.full(., alpha = alphas[13], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.a.matched = m4.a[matched.items.extras, ]
m4.a.matched$degree = ifelse(m4.a.matched$degree == "hi1", "hi", "low")
m4.a.matched = cbind(m4.a.matched, data.partial$listener.p)
all(m4.a.matched$scale == data.partial$scale & m4.a.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.a.matched)[length(colnames(m4.a.matched))] = "e6.listener.p"
# Store output
performance.output[13, ] = c("m4.a", round(cor(m4.a.matched$e6.listener.p, m4.a.matched$pred), 5),
round(cor(m4.a.matched$listener.p, m4.a.matched$pred), 5), T)
# Store plot
m4.a.plot = qplot(stars, e6.listener.p, col=degree,
data=m4.a.matched,
main=paste("m4.a\nalpha: ", alphas[13],
"\nNormalized = ", T,
"\nCorr = ", performance.output[13, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.b)
# Emp alts + extras
# Normalized = F
# alpha tune = F
alphas[14] = 1
m4.b = data.full.extras %>%
do(run.full(., alpha = alphas[14], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.b.matched = m4.b[matched.items.extras, ]
m4.b.matched$degree = ifelse(m4.b.matched$degree == "hi1", "hi", "low")
m4.b.matched = cbind(m4.b.matched, data.partial$listener.p)
all(m4.b.matched$scale == data.partial$scale & m4.b.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.b.matched)[length(colnames(m4.b.matched))] = "e6.listener.p"
# Store output
performance.output[14, ] = c("m4.b", round(cor(m4.b.matched$e6.listener.p, m4.b.matched$pred), 5),
round(cor(m4.b.matched$listener.p, m4.b.matched$pred), 5), F)
# Store plot
m4.b.plot = qplot(stars, e6.listener.p, col=degree,
data=m4.b.matched,
main=paste("m4.b\nalpha: ", alphas[14],
"\nNormalized = ", F,
"\nCorr = ", performance.output[14, 2]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.c)
# Emp alts + extras
# Normalized = T
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[15] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=T)
m4.c = data.full.extras %>%
do(run.full(., alpha = alphas[15], addMid=T, normalize=T))
# Match with e6 w/ checks
m4.c.matched = m4.c[matched.items.extras, ]
m4.c.matched$degree = ifelse(m4.c.matched$degree == "hi1", "hi", "low")
m4.c.matched = cbind(m4.c.matched, data.partial$listener.p)
all(m4.c.matched$scale == data.partial$scale & m4.c.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.c.matched)[length(colnames(m4.c.matched))] = "e6.listener.p"
# Store output (e11 and e6)
performance.output[15, ] = c("m4.c", round(cor(m4.c.matched$e6.listener.p, m4.c.matched$pred), 5),
round(cor(m4.c.matched$listener.p, m4.c.matched$pred), 5), T)
# Store plot 2 - both e6 and e11 data
m4.c.jointD = m4.c.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m4.c.jointD$study = ifelse(m4.c.jointD$study == "e6.listener.p", "e6", "e11")
m4.c.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m4.c.jointD,
main=paste("m4.c\nalpha: ", alphas[15],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
# 4.d)
# Emp alts + extras
# Normalized = F
# alpha tune = T
# compare.data = Toggle this with data.partial or NULL
alphas[16] = tune.alpha(data.full.extras, type = "full", compare.data=data.partial, addMid=T, normalize=F)
m4.d = data.full.extras %>%
do(run.full(., alpha = alphas[16], addMid=T, normalize=F))
# Match with e6 w/ checks
m4.d.matched = m4.d[matched.items.extras, ]
m4.d.matched$degree = ifelse(m4.d.matched$degree == "hi1", "hi", "low")
m4.d.matched = cbind(m4.d.matched, data.partial$listener.p)
all(m4.d.matched$scale == data.partial$scale & m4.d.matched$degree == data.partial$degree)
## [1] TRUE
colnames(m4.d.matched)[length(colnames(m4.d.matched))] = "e6.listener.p"
# Store output
performance.output[16, ] = c("m4.d", round(cor(m4.d.matched$e6.listener.p, m4.d.matched$pred), 5),
round(cor(m4.d.matched$listener.p, m4.d.matched$pred), 5), F)
# Store plot 2 - both e6 and e11 data
m4.d.jointD = m4.d.matched %>%
gather(study, listener.pred, listener.p, e6.listener.p)
m4.d.jointD$study = ifelse(m4.d.jointD$study == "e6.listener.p", "e6", "e11")
m4.d.jointPlot = qplot(stars, listener.pred, col=degree, shape=study,
data=m4.d.jointD,
main=paste("m4.d\nalpha: ", alphas[16],
"\nNormalized = ", T,
ylab="Posterior p(rating | word)")) +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
m1: Entailment only models (i.e. “some_all” scale only includes “some”, “all”)
m2: Entailment + generic None models (i.e. “some_all” scale includes “none”, “some”, “all”)
m3: Full model with empirical alternatives (i.e. “some_all” scale includes “none”, “some”, “most”, all“)
m4: Entailment + empirical alternatives + additional fitted scalar (i.e. “some_all” scale includes “none”, “some”, “mid”, “most”, all“)
a: Normalized literal listener values before running RSA, no alpha tuning
b: No normalization for literal listener values before running RSA, no alpha tuning
c: Normalized literal listener values before running RSA, alpha tuning
d: No normalization for literal listener values before running RSA, alpha tuning
performance.output$cor.e6 = as.numeric(performance.output$cor.e6)
performance.output$cor.e11 = as.numeric(performance.output$cor.e11)
performance.output = performance.output %>%
mutate(avg.corr =
(cor.e6 + cor.e11) / 2)
performance.output = cbind(performance.output, alphas)
# reorder columns
performance.output = performance.output[, c(1, 2, 3, 5, 4, 6)]
grid.table(performance.output)
Across e6 and e11 pragmatic listener judgements we see model fit improve as we add more alternatives. The largest improvement in model fit occurs when we first include the empirically derived salient alternatives (correlations jump +0.23). Have a look at the m2 vs m3 correlation for models with pre-RSA normalization below (c models):
# Tuned, normalized models r
barchart.d = performance.output[c(3, 7, 11, 15), ] %>%
gather(study, cor, cor.e6, cor.e11)
barchart.d$cor = as.numeric(barchart.d$cor)
ggplot(barchart.d, aes(x=model, y=cor, fill=study)) +
geom_bar(stat="identity", position="dodge") +
ylim(0, 1) +
ggtitle("Model fit for e6 and e11\npragmatic listener judgments") +
geom_text(aes(x=model, y=as.numeric(cor) + 0.025, label=round(cor, 3), col=(study)))
Here’s another look at the improvement in model fit between normalized m2 and m3.
m2.c.plot
m3.c.jointPlot
Importantly, we also see improvements with the addition of ‘fitted’ alternatives in m4 see the plots below:
m3.c.jointPlot
m4.c.jointPlot
This presents a little bit more of a challenge, however, as we’d like to jointly fit our alpha as well as our alternatives - is this worth delving into? Currently we’re just fitting alpha and then finding alternatives.
https://cdn.rawgit.com/langcog/scalar_implicature/master/models/RSA%2BAmbiguousSemantics.html#pragmatic-listener-studies—judgement-distributional-differences
Our best model performance occurs with e11 and the model is m4.c, correlation = 0.93492 (see plot below):
qplot(stars, listener.p, col=degree,
data=m4.c.matched,
main=paste("m4.c\nalpha: ", alphas[15],
"\nNormalized = ", T,
"\nCorr = ", performance.output[15, 3]),
ylab="Posterior p(rating | word)") +
ylim(0, 1) +
facet_wrap(~scale) +
geom_line(aes(y = pred), lty = 4)
Normalizing vs not normalizing before running RSA:
Non-normalized models seem to be more sensitive to alpha tuning as the number of alternatives increases (see m4.d and m3.d with alpha = 8). I’m not sure if there is a theoretical consideration here that RSA may want to address? What does it mean to normalize literal listener values prior to computing the posterior? One repercussion is that during normalization we’ll see larger impact from salient alternatives… In Model_addtionalAlts.Rmd I’m seeing that higher entropy scales memorable_unforgettable, palatable_delicious appear to be looking for more alternatives (correlation improves when I add wacky distributions such as [0, 0.1, 0.9, 0.1, 0.9] which suggests that we need possibly two more alternatives, not just one). This seems intuitive in the higher entropy setting… Can we interpret this kind of finding (at least intuitively) as the model telling us it wants more alternatives? See
m1.a.plot
m1.b.plot
m1.c.plot
m1.d.plot
m2.a.plot
m2.b.plot
m2.c.plot
m2.d.plot
m3.a.plot
m3.b.plot
m3.c.jointPlot
m3.d.jointPlot
m4.a.plot
m4.b.plot
m4.c.jointPlot
m4.d.jointPlot
# bad.predictions = m3.fit.matched$pred > 0 &
# m3.fit.matched$e6.listener.p == 0 &
# (m3.fit.matched$pred - m3.fit.matched$e6.listener.p > 0.05)